home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / sources.lha / sources / comp / back_end / lookup.t < prev    next >
Encoding:
Text File  |  1988-02-05  |  15.5 KB  |  346 lines
  1. (herald (back_end lookkup)
  2.   (env t (orbit_top defs) (back_end closure) (back_end bookkeep)))
  3.  
  4. (define (all-important-refs-are-calls? var)
  5.   (every? (lambda (ref)
  6.         (or (eq? (node-role ref) call-proc)
  7.         (and (eq? (node-role ref) (call-arg 2))
  8.              (let ((call (node-parent ref)))
  9.                (or (primop-ref? (call-proc call) primop/*define)
  10.                (primop-ref? (call-proc call) primop/*lset))))))
  11.       (variable-refs var)))
  12.  
  13. (define (var-is-vcell? var)
  14.   (and (not (all-important-refs-are-calls? var))
  15.        (neq? var *the-environment*)))
  16.  
  17. ;;; ACCESS-VALUE This is the primary routine to get addressability to values.
  18. ;;; Just a giant case statement.
  19.  
  20.  
  21. (define (access-value node value)
  22.   (cond ((and (variable? value)
  23.           (not (variable-binder value))
  24.           (var-is-vcell? value))
  25.      (let ((acc (lookup node (get-lvalue value) nil)))
  26.        (let ((reg (get-register 'pointer node '*)))
  27.          (generate-move acc reg)
  28.          (reg-offset reg 2))))
  29.     (else
  30.      (really-access-value node value))))
  31.  
  32. (define (really-access-value node value)               
  33.  (let ((value (cond ((and (variable? value) (variable-known value))
  34.                      => lambda-self-var)
  35.                     (else value))))
  36.   (cond ((register-loc value)
  37.          => (lambda (spec)
  38.               (cond ((fixnum? spec))
  39.                     (else
  40.                      (cond ((pair? (car spec))
  41.                             (unlock (caar spec))
  42.                             (cond ((reg-node (caar spec))
  43.                                    => (lambda (var) (kill-if-dying var node))))
  44.                             (unlock (cdar spec)))
  45.                            (else
  46.                             (unlock (car spec))
  47.                             (cond ((reg-node (car spec))
  48.                                    => (lambda (var) (kill-if-dying var node))))))
  49.                      (set (register-loc value) nil)))
  50.               spec))
  51.         ((temp-loc value))
  52.         ((variable? value)
  53.          (let ((binder (variable-binder value)))
  54.            (cond ((not binder)
  55.                   (lookup node value nil))
  56.                  ((and (fx= (variable-number value) 0) 
  57.                        (assq binder (closure-env *unit*)))
  58.                   (lookup node binder nil))
  59.                  (else
  60.                   (lookup node value binder)))))
  61.         ((primop? value)
  62.          (if (eq? value primop/undefined)
  63.              (machine-num 0)
  64.              (lookup node value nil)))
  65.         ((eq? value '#T)
  66.          (machine-num header/true))
  67.         ((or (eq? value '#F) (eq? value '()))
  68.           nil-reg)
  69.         ((addressable? value)
  70.          (lit value))
  71.         (else
  72.          (lookup node value nil)))))
  73.  
  74.  
  75. ;;; LOOKUP If the value is a known procedure, if it is in the unit we get it
  76. ;;; from there, otherwise we get the variable which the known procedure is
  77. ;;; bound to.
  78.  
  79. (define (lookup node value lambda-bound?)
  80.   (xselect (lambda-strategy *lambda*)
  81.     ((strategy/stack strategy/ezclose)
  82.      (fetch-from-stack node value lambda-bound?))
  83.     ((strategy/vframe strategy/hack)
  84.      (let ((contour (lambda-self-var *lambda*)))
  85.        (->register 'pointer node contour '*)
  86.        (fetch-from-vframe node contour value lambda-bound?)))
  87.     ((strategy/heap)
  88.      (let ((contour (lambda-self-var *lambda*)))
  89.        (->register 'pointer node contour '*)
  90.        (fetch-from-heap node contour value lambda-bound?)))))
  91.  
  92.  
  93.                                 
  94. ;;; ACCESS-FROM-UNIT Get from unit when there is a closure-internal-template.
  95. ;;; If we have one, just offset from template-pointer. If we are internal to
  96. ;;; a closure which has one, get it first and then offset into unit.
  97.  
  98.  
  99. (define (access-from-unit node contour var)
  100.   (let ((closure (environment-closure (lambda-env (variable-binder contour)))))
  101.     (cond ((closure-cit-offset closure)
  102.            => (lambda (current-offset) 
  103.                 (let ((cl? (or (and (node? var) (lambda-node? var))
  104.                            (closure? var)))
  105.                       (disp (fx- (cdr (assq var (closure-env *unit*))) 
  106.                                  (fx+ current-offset tag/extend))))
  107.                   (cond ((and (eq? (lambda-strategy *lambda*) strategy/heap)
  108.                               (eq? contour (car (closure-members closure))))
  109.                          (if cl?
  110.                              (list (reg-offset TP (fx+ disp tag/extend)))
  111.                              (reg-offset TP disp)))
  112.                         ((register-loc (variable-binder (car (closure-members closure))))
  113.                          => (lambda (reg)
  114.                               (if cl?
  115.                                   (list (reg-offset reg (fx+ disp tag/extend)))
  116.                                   (reg-offset reg disp))))
  117.                         (else
  118.                          (let* ((c-reg (register-loc contour))
  119.                                 (reg (get-register 'pointer node '*)))
  120.                            (generate-move
  121.                               (reg-offset c-reg
  122.                                           (fx- (fx- 0 tag/extend)
  123.                                                (cdr (assq contour
  124.                                                     (closure-env closure)))))
  125.                               reg)                        
  126.                            (mark (variable-binder (car (closure-members closure)))
  127.                                  reg)
  128.                            (if cl?
  129.                                (list (reg-offset reg (fx+ disp tag/extend)))
  130.                                (reg-offset reg disp))))))))
  131.           (else nil))))
  132.  
  133.  
  134. (define (get-env var)
  135.   (lambda-env (variable-binder var)))
  136.                                       
  137.  
  138. ;;; Yukk.  Here we get a variable from a stack frame.  If it is in the frame
  139. ;;; we are OK.  Otherwise we chain down stack frames as long as they are there.
  140. ;;; These frames are all simple offsets from SP.  When we arrive at a pointer
  141. ;;; into the heap, we load that pointer into a register and go to the heap
  142. ;;; code to do the rest.
  143.  
  144. (define (fetch-from-vframe node contour value lambda-bound?)
  145.   (iterate loop ((offset 0) (l (variable-binder contour)))
  146.     (select (lambda-strategy l)
  147.       ((strategy/label strategy/open)
  148.        (loop offset (node-parent (node-parent l))))
  149.       (else
  150.        (cond ((not (lambda-env l))
  151.               (loop offset (node-parent (node-parent l))))
  152.              (else
  153.               (let* ((env (lambda-env l))
  154.                      (closure (environment-closure env)))
  155.                 (cond ((and lambda-bound? (assq value (closure-env closure)))
  156.                        => (lambda (env-pair) 
  157.                             (reg-offset (register-loc contour)
  158.                                         (fx+ (fx- (cdr env-pair) tag/extend)
  159.                                              (fx- offset
  160.                                                   (environment-cic-offset env))))))
  161.                       ((closure-link closure)
  162.                        => (lambda (link)
  163.                        (let ((accessor (reg-offset (register-loc contour)
  164.                                                    (fx- (fx+ offset CELL)
  165.                                                  (fx+ (environment-cic-offset env) tag/extend)))))
  166.                          (into-register 'pointer node link accessor '*)
  167.                          (xselect (lambda-strategy (variable-binder link))
  168.                             ((strategy/heap) 
  169.                              (fetch-from-heap node link value lambda-bound?))
  170.                             ((strategy/vframe strategy/hack) 
  171.                              (fetch-from-vframe node link value lambda-bound?))))))
  172.                       ((labels-master-lambda? l)
  173.                        (let* ((p (node-parent l))
  174.                               (node ((call-arg 1) p)))
  175.                          (cond ((lambda-node? node)
  176.                                 (loop (fx+ (fx- (closure-size closure) 
  177.                                                 (environment-cic-offset env))
  178.                                            (fx+ offset
  179.                                                 (closure-size 
  180.                                                   (environment-closure
  181.                                                     (lambda-env node)))))
  182.                                       (node-parent p)))
  183.                                (else 
  184.                                 (loop (fx+ (fx- (closure-size closure) 
  185.                                                 (environment-cic-offset env))
  186.                                            offset)
  187.                                       (node-parent p))))))
  188.                       (else
  189.                        (loop (fx+ (fx- (closure-size closure) 
  190.                                        (environment-cic-offset env))
  191.                                   offset)
  192.                              (node-parent (node-parent l))))))))))))
  193.  
  194.                                                  
  195. (define (fetch-from-stack node value lambda-bound?)
  196.   (iterate loop ((offset 0) (l *lambda*))
  197.     (select (lambda-strategy l)
  198.       ((strategy/open)
  199.        (loop offset (node-parent (node-parent l))))
  200.       ((strategy/label strategy/heap)
  201.        (let* ((p (node-parent l))
  202.               (node ((call-arg 1) p)))
  203.          (cond ((and (labels-master-lambda? l) (lambda-node? node))
  204.                 (loop (fx+ (closure-size (environment-closure (lambda-env node)))
  205.                            offset)
  206.                       (node-parent p)))
  207.                (else 
  208.                 (loop offset (node-parent p))))))
  209.       (else
  210.        (cond ((not (lambda-env l))
  211.               (loop offset (node-parent (node-parent l))))
  212.              (else
  213.               (let ((closure (environment-closure (lambda-env l))))
  214.                 (cond ((and lambda-bound? (assq value (closure-env closure)))
  215.                        => (lambda (env-pair) 
  216.                             (reg-offset SP (fx+ offset 
  217.                                                 (fx+ *stack-pos* (cdr env-pair))))))
  218.                       ((closure-link closure)
  219.                        => (lambda (link)
  220.                        (let ((accessor (reg-offset SP (fx+ *stack-pos*
  221.                                                             (fx+ offset CELL)))))
  222.                          (into-register 'pointer node link accessor '*)
  223.                          (xselect (lambda-strategy (variable-binder link))
  224.                             ((strategy/heap) 
  225.                              (fetch-from-heap node link value lambda-bound?))
  226.                             ((strategy/vframe strategy/hack) 
  227.                              (fetch-from-vframe node link value lambda-bound?))))))
  228.                       ((labels-master-lambda? l)
  229.                        (let* ((p (node-parent l))
  230.                               (node ((call-arg 1) p)))
  231.                          (cond ((lambda-node? node)
  232.                                 (loop (fx+ (fx+ (closure-size closure)
  233.                                                 (closure-size (environment-closure
  234.                                                                 (lambda-env node))))
  235.                                            offset)
  236.                                       (node-parent p)))
  237.                                (else 
  238.                                 (loop (fx+ (closure-size closure) offset)
  239.                                       (node-parent p))))))
  240.                       (else
  241.                        (loop (fx+ (closure-size closure) offset)
  242.                              (node-parent (node-parent l))))))))))))
  243.                           
  244.  
  245.  
  246. (define (closure-internal-closure? value closure)
  247.   (cond ((neq? closure *unit*)
  248.          (memq? value (closure-members closure)))
  249.         (else
  250.          (or (and (node? value) (lambda-node? value))
  251.              (closure? value)))))
  252.  
  253. (define (fetch-from-heap node contour value lambda-bound?) 
  254.   (iterate loop ((env (get-env contour)) (contour contour)) 
  255.     (let ((a-list (closure-env (environment-closure env)))
  256.           (current-offset (environment-cic-offset env)))
  257.       (cond ((assq value a-list)
  258.              => (lambda (pair)
  259.                   (if (closure-internal-closure? value
  260.                                                  (environment-closure env))
  261.                       (list (reg-offset (register-loc contour)  ; *** hack
  262.                                         (fx- (cdr pair) current-offset)))
  263.                       (reg-offset (register-loc contour)
  264.                                   (fx- (cdr pair)
  265.                                        (fx+ current-offset tag/extend))))))
  266.             ((and (not lambda-bound?) (access-from-unit node contour value)))
  267.             ((neq? (environment-closure env) *unit*)
  268.              (into-register 'pointer node (caadr a-list)
  269.                 (reg-offset  (register-loc contour)
  270.                              (fx+ (fx- 0 current-offset) tag/extend))
  271.                 '*)
  272.              (loop (get-env (caadr a-list)) (caadr a-list)))
  273.             (else
  274.              (bug "Couldn't find ~s~% in call ~s"
  275.                   value
  276.                   (pp-cps node)))))))
  277.  
  278. ;;; Code to get a continuation off the stack.
  279. ;;; Search up the tree until we find it.
  280. ;;; This relies on generating code for the body of a labels FIRST.
  281.  
  282.  
  283. (define (fetch-continuation-from-stack node var)
  284.   (iterate loop ((offset 0) (l (node-parent node)))
  285.     (cond ((eq? (variable-binder var) l)
  286.            offset)
  287.           (else
  288.            (select (lambda-strategy l)
  289.              ((strategy/stack)
  290.               (loop (fx+ (closure-size (environment-closure (lambda-env l)))
  291.                          offset)
  292.                    (node-parent (node-parent l))))
  293.              (else
  294.               (loop offset (node-parent (node-parent l)))))))))
  295.  
  296. (define (restore-continuation node leaf)
  297.   (let ((proc (call-proc node)))
  298.     (let ((stop (cond ((primop-node? proc) nil)
  299.                       ((variable-known (reference-variable proc))
  300.                        => (lambda (l)
  301.                             (let ((p (node-parent (node-parent l))))
  302.                               (if (labels-master-lambda? p) p nil))))
  303.                       (else nil))))
  304.       (really-restore-continuation node (leaf-value leaf) stop))))
  305.  
  306. (define (restore-ezclose-continuation node proc)
  307.   (really-restore-continuation node (leaf-value ((call-arg 1) node))
  308.                                     (node-parent (node-parent proc))))
  309.  
  310. (define (restore-vframe-continuation node proc)
  311.   (really-restore-continuation node (leaf-value ((call-arg 1) node))
  312.                                     (node-parent (node-parent proc))))
  313.  
  314.  
  315. (define (really-restore-continuation node var stop)
  316.   (let* ((binder (variable-binder var))
  317.          (y-lambda (node-parent (node-parent binder)))
  318.          (n (fetch-continuation-from-stack node var)))
  319.     (if (not (labels-master-lambda? y-lambda))
  320.         (adjust-stack-pointer n)
  321.         (select (lambda-strategy y-lambda)
  322.           ((strategy/heap)           
  323.            (if (eq? (node-role binder) (call-arg 1))
  324.                (let ((pair (lambda-live y-lambda)))
  325.                  (remove-stack (cdr pair) (fx+ n (car pair)) nil))
  326.                (adjust-stack-pointer n)))
  327.           (else                       
  328.            (remove-stack y-lambda n stop))))))
  329.  
  330. (define (remove-stack y-lambda n stop)
  331.   (iterate loop ((y-lambda y-lambda)
  332.                  (n n))
  333.     (if (or (null? y-lambda) (eq? y-lambda stop))
  334.         (adjust-stack-pointer n)
  335.         (select (lambda-strategy y-lambda)
  336.           ((strategy/ezclose strategy/label)
  337.            (let ((pair (lambda-live y-lambda)))
  338.              (loop (cdr pair) (fx+ (car pair) n))))
  339.           ((strategy/vframe)
  340.            (adjust-stack-pointer n)
  341.            (let ((pair (lambda-live y-lambda)))                   
  342.              (generate-vframe-test (car pair))
  343.              (loop (cdr pair) 0)))
  344.           (else 
  345.            (adjust-stack-pointer n))))))
  346.